home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / byt86sep.arc / SKAM1.BAS < prev    next >
BASIC Source File  |  1980-01-01  |  9KB  |  254 lines
  1.  
  2.  
  3. 1  '---------------------------------------------------------
  4. 2  '         SAMPLE PROGRAM USING KEYED ACCESS ROUTINES     -
  5. 3  ' --------------------------------------------------------
  6. 5  UA$="A"   ' .. DRIVE CONTAINING DATA
  7. 16 OPEN "R",#2,UA$+":DATA.EMP",84  ' .. OPEN DATA FILE
  8. 17 FIELD #2, 9 AS KY$, 20 AS NM$, 6 AS BD$, 1 AS SX$, 3 AS JC$,
  9.    20 AS A1$, 20 AS A2$, 5 AS ZP$
  10. 18 '
  11. 19 '    KY$ - ZIP CODE (KEY) JC$ - JOB CODE
  12. 20 '    NM$ - NAME           A1$ - STREET ADDR.
  13. 21 '    BD$ - BIRTH DATE     A2$ - CITY-STATE
  14. 22 '    SX$ - SEX            ZP$ - ZIP CODE
  15. 23 '
  16. 25 MX%=150: F1$="PTR.EMP"     ' ..INDEX FILE NAME
  17. 30 II%=1: GOSUB 2000          ' ..INITIALIZE DATA STRUCTURE
  18. 31 '
  19. 32 INPUT "OPERATION (D,A,L,S,LA,U,Q)";Q$
  20. 33 IF Q$="D" THEN GOSUB 150: GOTO 32         ' DELETE
  21. 34 IF Q$="L" THEN GOSUB 180:
  22.    GOTO 32         ' LIST INDIVIDUAL DATA
  23. 35 IF Q$="A" THEN GOSUB 100: GOTO 32         ' ADD
  24. 36 IF Q$="S" THEN II%=8: GOSUB 2000:
  25.    GOTO 32         ' DISPLAY STATISTICS
  26. 37 IF Q$="LA"THEN GOSUB 200:
  27.    GOTO 32         ' LIST ALL RECORDS
  28. 38 IF Q$="U" THEN GOSUB 250: GOTO 32         ' UPDATE RECORD
  29. 40 IF Q$<>"Q" THEN 32
  30. 50 CLOSE: END
  31. 97  '
  32. 98  ' ***** ADD RECORD
  33. 99  '
  34. 100  INPUT "SS#";A$ : IF A$="END" THEN 120 ELSE IF
  35.      LEN(A$)<>9 THEN 100
  36. 101  II%=5:GOSUB 2000: IF RC%<>0 THEN LSET KY$=A$: GOTO 102 ELSE
  37.      PRINT"** ERROR - KEY ALREADY EXISTS": GOTO 100
  38. 102  INPUT "NAME";F$: LSET NM$=F$
  39. 105  INPUT "BIRTH DATE";F$: LSET BD$=F$
  40. 107  INPUT "SEX";F$: LSET SX$=F$
  41. 109  INPUT "JOB CODE";F$: LSET JC$=F$
  42. 110  INPUT "STREET";F$: LSET A1$=F$
  43. 111  INPUT "CITY-STATE";F$: LSET A2$=F$
  44. 112  INPUT "ZIP CODE";F$: LSET ZP$=F$
  45. 115  II%=2: GOSUB 2000      '.. ADD RECORD
  46. 116  IF RC%=0 THEN 100 ELSE PRINT"** ERROR - RECORD CANNOT 
  47.      BE STORED": GOTO 100
  48. 120  II%=7: GOSUB 2000      '.. STORE POINTERS
  49. 122  RETURN
  50. 147 '
  51. 148 ' ***** DELETE RECORD
  52. 149 '
  53. 150 ST%=0
  54. 151 INPUT "CODE TO DELETE";A$: IF A$="END" THEN 156
  55. 152 II%=4: GOSUB 2000
  56. 154 IF RC%=0 THEN ST%=1 ELSE  PRINT "** ERROR - KEY DOES NOT
  57.     EXIST"
  58. 155 GOTO 151
  59. 156 IF ST%=1 THEN II%=7: GOSUB 2000  ' RESTORE POINTERS
  60.                                        IF RECORD DELETED
  61. 158 RETURN
  62. 177 '
  63. 178 ' ***** LIST INDIVIDUAL RECORD
  64. 179 '
  65. 180 INPUT "SOCIAL SECURITY NUMBER";A$: IF A$="END" THEN 190
  66. 182 II%=5: GOSUB 2000: IF RC%<>0 THEN PRINT"**ERROR - KEY
  67.     DOES NOT EXIST": GOTO 180
  68. 183 PRINT " "
  69. 184 PRINT "      NAME: ";NM$
  70. 185 PRINT "  JOB CODE: ";JC$
  71. 186 PRINT "BIRTH DATE: ";LEFT$(BD$,2);"/";MID$(BD$,3,2);
  72.     "/";RIGHT$(BD$,2)
  73. 187 PRINT "   ADDRESS: ";A1$
  74. 188 PRINT TAB(13);A2$:PRINT ""
  75. 189 GOTO 180
  76. 190 RETURN
  77. 197 '
  78. 198 ' ***** LIST RANGE OF RECORDS
  79. 199 '
  80. 200 NX%=0: II%=6: K%=0
  81. 202 NX%=NX%+1: GOSUB 2000
  82. 204 IF RC%<>0 THEN 210
  83. 205 PRINT KY$,NM$
  84. 206 K%=K%+1: IF K%<10 THEN 202 ELSE INPUT ">";Q$  ' .. PAUSE
  85. 207 IF Q$<>"END" THEN K%=0: GOTO 202
  86. 210 RETURN
  87. 247 '
  88. 248 ' ***** UPDATE RECORD
  89. 249 '
  90. 250 INPUT "SS#";A$: IF A$="END" THEN 270
  91. 252 II%=5:GOSUB 2000    ' .. FETCH RECORD TO BE UPDATED
  92. 254 IF RC%=1 THEN PRINT "** ERROR - RECORD DOES NOT EXIST":
  93.     GOTO 250
  94. 255 PRINT "NAME: /";NM$;"/";: INPUT F$: IF LEN(F$)<>0 
  95.     THEN LSET NM$=F$
  96. 257 PRINT "BIRTH DATE: /";BD$;"/";: INPUT F$: IF LEN(F$)<>0 
  97.     THEN LSET BD$=F$
  98. 258 PRINT "SEX: /";SX$;"/";: INPUT F$: IF LEN(F$)<>0 
  99.     THEN LSET SX$=F$
  100. 260 PRINT "JOB CODE: /";JC$;"/";: INPUT F$: IF LEN(F$)<>0 
  101.     THEN LSET JC$=F$
  102. 262 PRINT "STREET: /";A1$;"/";: INPUT F$: IF LEN(F$)<>0
  103.     THEN LSET A1$=F$
  104. 263 PRINT "CITY-STATE: /";A2$;"/";: INPUT F$: IF LEN(F$)<>0
  105.     THEN LSET A2$=F$
  106. 265 PRINT "ZIP CODE: /";ZP$;"/";: INPUT F$: IF LEN(F$)<>0
  107.     THEN LSET ZP$=F$
  108. 266 II%=3: GOSUB 2000   ' .. RESTORE UPDATED RECORD
  109. 268 PRINT " ": GOTO 250
  110. 270 RETURN
  111. 1995 '
  112. 1996 ' -----------------------------------------------------
  113. 1997 ' -             FILE MANAGEMENT SUBROUTINES
  114.                   (II%,MX%,F1$,A$,PT%,PT$, NX%,RC%)  -
  115. 1998 ' -----------------------------------------------------
  116. 1999 '
  117. 2000 RC%=0: IF II%<1 OR II%>8 THEN RC%=1: RETURN
  118. 2001 IF II%=1 THEN 2006:  ' ELSE STORE VARIABLES
  119.      USED BY SUBROUTINES
  120. 2004 ZZ%(1)=J%: ZZ%(2)=JJ%: ZZ%(3)=K%:ZZ%(4)=LO%:
  121.      ZZ%(5)=HI%: ZZ%(6)=Z%
  122. 2005 '
  123. 2006 ON II% GOSUB 2035,2080,2090,2100,2150,2200,2250,2280
  124. 2007 '
  125. 2008 IF II%=1 THEN 2010:  ' ELSE RESTORE VARIABLES
  126.      USED BY SUBROUTINES
  127. 2009 J%=ZZ%(1): JJ%=ZZ%(2): K%=ZZ%(3): LO%=ZZ%(4): HI%=ZZ%(5):
  128.      Z%=ZZ%(6)
  129. 2010 RETURN
  130. 2034 REM --- (1) SUBROUTINE (MX%,F1$) --- INPUT POINTERS
  131.      AND KEYS
  132. 2035 IF MX%<1 THEN RC%=1: RETURN
  133. 2037 MR%=(INT((MX%+2)/64)+1)*64
  134. 2038 DIM PT$(64),PT%(MR%),KE$(MX%),ZZ%(8)
  135. 2040 OPEN "R",#1,UA$+":"+F1$,128  ' INDEX FILE
  136. 2042 FOR J%=1 TO 64: FIELD #1,(J%-1)*2 AS DU$,
  137.      2 AS PT$(J%): NEXT J%
  138. 2050 K%=0: IF LOF(1)=0 THEN 2062
  139. 2051 FOR J%=1 TO INT(MR%/64)
  140. 2052 GET 1,J%  ' .. INPUT RECORD CONTAINING 64 POINTERS
  141. 2054 FOR JJ%=1 TO 64: K%=K%+1: PT%(K%)=CVI(PT$(JJ%)):
  142.      NEXT JJ%
  143. 2055 NEXT J%
  144. 2056 '
  145. 2057 IF PT%(MR%)=0 THEN 2062
  146. 2058 FOR J%=1 TO PT%(MR%)+PT%(MR%-1)
  147. 2059 GET 2, J%: KE$(J%)=KY$
  148. 2060 NEXT J%
  149. 2062 RETURN
  150. 2079 REM --- (2) SUBROUTINE (MR%,A$, RC%) -- ADD
  151.      RECORD TO FILE
  152. 2080 GOSUB 2500 : IF K%>0 THEN RC%=1: GOTO 2088
  153. 2083 GOSUB 2520 : IF Z%>MR%-1 THEN RC%=2: GOTO 2088
  154. 2085 K%=-K%:GOSUB 2540   ' .. INSERT POINTER . PT%(K%)=Z%
  155. 2086 KE$(Z%)=A$
  156. 2087 PUT 2,Z% ' .. STORE NEW RECORD
  157. 2088 RETURN
  158. 2089 REM -- (3) SUBROUTINE --- REWRITE RECORD
  159. 2090 GOSUB 2500: IF K%<0 THEN RC%=1: GOTO 2098
  160. 2092 PUT 2,PT%(K%)  ' .. STORE RECORD
  161. 2098 RETURN
  162. 2099 REM --- (4) SUBROUTINE (MR%,A$,RC%) --- DELETE
  163.      A RECORD
  164. 2100 GOSUB 2500: IF K%<0 THEN RC%=1: GOTO 2110
  165. 2102 Z%=PT%(K%): IF K%=PT%(MR%) THEN 2107
  166. 2104 FOR J%=K% TO PT%(MR%)-1: PT%(J%)=PT%(J%+1): NEXT J%
  167. 2107 JJ%=PT%(MR%-1)
  168. 2108 PT%(PT%(MR%))=0: PT%(MR%)=PT%(MR%)-1: 
  169.      PT%(MR%-1)=JJ%+1:PT%(MR%-2-JJ%)=Z%
  170. 2110 RETURN
  171. 2149 REM --- (5) SUBROUTINE (MR%,A$,NX%,RC%) --- READ
  172.      RECORD BY KEY
  173. 2150 GOSUB 2500: IF K%<0 THEN RC%=1: GOTO 2155
  174. 2152 GET 2,PT%(K%)    '.. INPUT RECORD
  175. 2153 NX%=K%
  176. 2155 RETURN
  177. 2199 REM --- (6) SUBROUTINE (MR%,NX%,RC%) --- READ 
  178.      RECORD BY SEQUENCE
  179. 2200 IF NX%<0 OR NX%>PT%(MR%) THEN RC%=1: GOTO 2205
  180. 2203 GET 2, PT%(NX%)
  181. 2205 RETURN
  182. 2249 REM --- (7) SUBROUTINE (MR%) --- RESTORE POINTERS
  183. 2250 K%=0: Z%=INT((PT%(MR%)-1)/64)+1
  184. 2252 FOR J%=1 TO Z%
  185. 2253 FOR JJ%=1 TO 64: K%=K%+1:LSET PT$(JJ%)=MKI$(PT%(K%)):
  186.      NEXT JJ%: PUT 1,J%
  187. 2254 NEXT J%
  188. 2255 K%=INT(MR%/64): IF Z%=K% THEN 2259
  189. 2257 K%=(K%-1)*64: FOR J%=1 TO 64:
  190.      LSET PT$(J%)=MKI$(PT%(J%+K%)):
  191.      NEXT J%:PUT 1,INT(MR%/64)
  192. 2259 RETURN
  193. 2279 REM --- (8) SUBROUTINE -- DISPLAY FILE STATISTICS
  194. 2280 PRINT " ":IF PT%(MR%)=0 THEN PRINT "** NO RECORDS
  195.      IN FILE": GOTO 2290
  196. 2282 PRINT "    ** FILE STATISTICS **": PRINT " "
  197. 2283 PRINT "  1. RECORDS IN FILE: ";PT%(MR%)
  198. 2284 PRINT "  2. DELETED RECORDS: ";PT%(MR%-1)
  199. 2285 PRINT "  3. LOWEST  KEY: ";KE$(PT%(1))
  200. 2286 PRINT "  4. HIGHEST KEY: ";KE$(PT%(PT%(MR%)))
  201. 2287 PRINT " "
  202. 2290 RETURN
  203. 2498 '
  204. 2499 REM --- SUBROUTINE (MR%,A$, K%) -- BINARY SEARCH
  205. 2500 IF PT%(MR%)=0 THEN K%=-1: RETURN
  206. 2502 LO%=0: HI%=PT%(MR%)+1
  207. 2504 M%=INT((LO%+HI%)/2)
  208. 2505 IF A$=KE$(PT%(M%)) THEN K%=M%: GOTO 2510
  209. 2506 IF A$>KE$(PT%(M%)) THEN LO%=M%: ELSE HI%=M%
  210. 2508 IF LO%+1 <> HI% THEN 2504 ELSE K%=-HI%
  211. 2510 RETURN
  212. 2518 '
  213. 2519 REM -- SUBROUTINE (MR%,PT%,Z%) -- LOCATE FREE
  214.      RECORD IN DATA FILE
  215. 2520 IF PT%(MR%-1)=0 THEN Z%=PT%(MR%)+1: GOTO 2530
  216. 2522 J%=PT%(MR%):JJ%=PT%(MR%-1)
  217. 2524 Z%=PT%(MR%-1-JJ%): PT%(MR%-1)=PT%(MR%-1)-1:
  218.      PT%(MR%-1-JJ%)=0
  219. 2530 RETURN
  220. 2538 '
  221. 2539 REM -- SUBROUTINE (MR%,K%,Z%) -- INSERT POINTER
  222.      INTO POINTER VECTOR
  223. 2540 IF K%=PT%(MR%)+1 THEN 2548
  224. 2542 FOR J%=PT%(MR%)+1 TO K%+1 STEP -1
  225. 2544 PT%(J%)=PT%(J%-1)
  226. 2545 NEXT J%
  227. 2548 PT%(K%)=Z%: PT%(MR%)=PT%(MR%)+1
  228. 2550 RETURN
  229. 2997 ' -----------------------------------------------------
  230. 2998 ' -         PROGRAM TO INITIALIZE INDEX FILE                   -
  231. 2999 ' -----------------------------------------------------
  232. 3000 PRINT " ":PRINT TAB(5);"** INITIALIZE INDEX
  233.      FILE **":PRINT " "
  234. 3001 INPUT "> DRIVE TO CONTAIN DATA";UA$
  235. 3002 INPUT "> FILE NAME";F$
  236. 3004 INPUT "> MAXIMUM NUMBER OF RECORDS FILE WILL HOLD";MX%
  237. 3006 MR%=(INT((MX%+2)/64)+1)*64
  238. 3008 DIM PT$(64)
  239. 3009 '--------------------------- OPEN FILE AND SET
  240.      POINTERS TO 0
  241. 3010 OPEN "R",#1,UA$+":"+F$,128
  242. 3012 FOR J%=1 TO 64: FIELD #1,(J%-1)*2 AS DU$,2
  243.      AS PT$(J%):NEXT J%
  244. 3014 ZR$=MKI$(0): FOR J%=1 TO 64: LSET PT$(J%)=ZR$: NEXT J%
  245. 3015 '--------------------------- STORE BLOCKS OF
  246.      ZERO POINTERS
  247. 3016 FOR J%=1 TO MR%/64
  248. 3018 PUT 1,J%
  249. 3020 NEXT J%
  250. 3022 PRINT " ": PRINT "   INITIALIZATION COMPLETE 
  251.      ON DRIVE";UA$
  252. 3025 END
  253.  
  254.